//=============================================================================
///	S-expression
/**
	xxx1	fixnum
	xx10	special
	xx00	pointer

*/
//=============================================================================

#include "sexp.h"
#include "smem.h"
#include "sutil.h"
#include "sstream.h"
#include "ssym.h"
#include "senv.h"
#include "seval.h"
#include "s_read.h"
#include "offsetof.h"
#include <string.h>
#include <stdlib.h>		// exit
#include <assert.h>

#ifndef	FALSE
#define	FALSE	(0)
#define	TRUE	(1)
#endif

static const char ERR_ARGLIST_MUST_BE_SYMBOL[] = "arglist must be symbol: ~a";
static const char ERR_DUPLICATE_ARGNAME[] = "duplicate argname: ~a";


SExp nil;
SExp t;
SExp call_list;
SExp current_eval_exp;

SExp (*error)(const char* msg, ...);


static SExp default_error_proc(const char* msg, ...) {
	fprintf(stderr, "%s\n", msg);
	exit(1);
	return nil;
}

SExp type_check(SExp s, SType type) {
	while (type_of(s) != type) {
		const char* typestrtbl[] = {
			"fixnum",
			"char",
			"cell",
			"symbol",
			"string",
			"stream",
			"specialform",
			"subr",
			"lambda",
			"macro",
			"table",
			"num",
		};
		s = error("type error: ~a is not ~a", s, intern(typestrtbl[type]));
	}
	return s;
}



//=============================================================================

void sexp_new(void) {
	sexp_set_error_callback(NULL);

	init_symbol_table();
	nil = intern("nil");
	t = intern("t");
	call_list = nil;
	current_eval_exp = nil;
	init_env();
	init_reader();
}

void sexp_delete(void) {
	term_env();
	term_symbol_table();
}

void sexp_set_error_callback(SExp (*cb)(const char*, ...)) {
	if (cb == NULL) {
		cb = default_error_proc;
	}
	error = cb;
}

SType type_of(SExp s) {
	switch (s.i & 3) {
	case 1: case 3:
		return tFixnum;
	case 0:
		return s.ptr->hdr.typeinfo->type;
	default:	// case 2:
		switch (GET_SUBTYPE(s.i)) {
		default:			return tUnknown;
		case SUBTYPE_CHAR:	return tChar;
		}
	}
}


//=============================================================================
// Fixnum

static void fixnum_write(SExp s, SExp strm, int escape) {
	char buf[16];
	sprintf(buf, "%d", s2fixnum(s));
	write_cstr(buf, strm);
}

static STypeInfo fixnum_typeinfo = {
	tFixnum,	0,
	"int",
	NULL,
	NULL,
	NULL,
	fixnum_write,
	NULL,
	NULL,
};


//=============================================================================
// not fixnum and pointer (EOF, ...)

static void unknown_write(SExp s, SExp strm, int escape) {
	write_cstr("???", strm);
}

static STypeInfo unknown_typeinfo = {
	tUnknown,	0,
	"???",
	NULL,
	NULL,
	NULL,
	unknown_write,
	NULL,
	NULL,
};


//=============================================================================
// Char

static void char_write(SExp s, SExp strm, int escape) {
	char buf[8];
	int c = GET_SUBVALUE(s.i);
	sprintf(buf, "#\\%c", c);
	write_cstr(buf, strm);
}

static STypeInfo char_typeinfo = {
	tChar,	0,
	"char",
	NULL,
	NULL,
	NULL,
	char_write,
	NULL,
	NULL,
};


//=============================================================================
// Cell

static const int cell_sexp_ofstbl[] = {
	offsetof(Cell, car),
	offsetof(Cell, cdr),
	-1,
};

static void print_cell(SExp p, SExp strm, int escape) {
	int b_first = TRUE;
	for (; consp(p); ) {
		if (!b_first)	write_cstr(" ", strm);
		write(car(p), strm, escape);
		p = cdr(p);
		b_first = FALSE;
	}
	if (!eq(p, nil)) {
		write_cstr(" . ", strm);
		write(p, strm, escape);
	}
}

static void cell_write(SExp s, SExp strm, int escape) {
	SExp d = cdr(s);
	if (consp(d)) {
		SExp dd = cdr(d);
		if (nilp(dd)) {
			SExp a = car(s);
			if (eq(a, intern("quote"))) {
				write_cstr("'", strm);
				write(car(d), strm, escape);
				return;
			} else if (eq(a, intern("quasiquote"))) {
				write_cstr("`", strm);
				write(car(d), strm, escape);
				return;
			} else if (eq(a, intern("unquote"))) {
				write_cstr(",", strm);
				write(car(d), strm, escape);
				return;
			} else if (eq(a, intern("unquote-splicing"))) {
				write_cstr(",@", strm);
				write(car(d), strm, escape);
				return;
			}
		}
	}
	write_cstr("(", strm);
	print_cell(s, strm, escape);
	write_cstr(")", strm);
}

static SExp cell_macroexpand(SExp self, SExp s) {
	SExp a = car(s);
	if (symbolp(a)) {
		return macroexpand_1(getvar(a), s);
	} else {
		int chg = FALSE;
		SExp p;
		push_stack(nil);
		for (p = s; !nilp(p); p = cdr(p)) {
			SExp v = car(p);
			SExp e = macroexpand_1(v, v);
			if (!eq(e, v)) {
				chg = TRUE;
			}
			push_stack(e);
			cons_on_stack();
		}
		if (chg) {
			return pop_nrev_stack();
		} else {
			pop_stack(1);
			return s;
		}
	}
}

static STypeInfo cell_typeinfo = {
	tCell,	0,
	"cons",
	cell_sexp_ofstbl,
	NULL,
	NULL,
	cell_write,
	NULL,
	cell_macroexpand,
};

SExp cons(SExp a, SExp d) {
	Cell* p = smalloc(sizeof(*p));
	p->typeinfo = &cell_typeinfo;
	p->car = a;
	p->cdr = d;
	return ptr2s(p);
}

SExp car(SExp s) {
	if (nilp(s)) {
		return nil;
	} else {
		Cell* p;
		s = type_check(s, tCell);
		p = &s.ptr->cell;
		return p->car;
	}
}

SExp cdr(SExp s) {
	if (nilp(s)) {
		return nil;
	} else {
		Cell* p;
		s = type_check(s, tCell);
		p = &s.ptr->cell;
		return p->cdr;
	}
}

void rplaca(SExp s, SExp a) {
	Cell* p;
	s = type_check(s, tCell);
	p = &s.ptr->cell;
	p->car = a;
}

void rplacd(SExp s, SExp d) {
	Cell* p;
	s = type_check(s, tCell);
	p = &s.ptr->cell;
	p->cdr = d;
}


//=============================================================================
// SpecialForm

static void sf_write(SExp s, SExp strm, int escape) {
	SpecialForm* p = &s.ptr->specialform;
	write_cstr("#<special-form: ", strm);
	write_cstr(p->name, strm);
	write_cstr(">", strm);
}

static int check_argnum(int n, int minargnum, int maxargnum) {
	return minargnum <= n && (maxargnum < 0 || n <= maxargnum);
}

static SExp argnum_error(SExp fn, int n, int minargnum, int maxargnum) {
#define	ARGNUM_ERROR	"wrong number of argments for ~a: #~a for "
	const char* errmsg;
	if (maxargnum < 0) {
		errmsg = ARGNUM_ERROR "#~a -";
	} else if (minargnum == maxargnum) {
		errmsg = ARGNUM_ERROR "#~a";
	} else {
		errmsg = ARGNUM_ERROR "#~a..#~a";
	}
	return error(errmsg, fn, fixnum2s(n), fixnum2s(minargnum), fixnum2s(maxargnum));
}

static SExp sf_apply(SExp fn, SExp args, int not_evaled) {
	SpecialForm* sf = &fn.ptr->specialform;
	int n = list_length(args);
	if (!check_argnum(n, sf->minargnum, sf->maxargnum)) {
		return argnum_error(intern(sf->name), n, sf->minargnum, sf->maxargnum);
	} else {
		return (sf->cfunc)(args, FALSE);
	}
}

static SExp sf_macroexpand(SExp self, SExp s) {
	SpecialForm* sf = &self.ptr->specialform;
	return (sf->cfunc)(s, TRUE);
}

static STypeInfo sf_typeinfo = {
	tSpecialForm,	0,
	"fn",
	NULL,
	NULL,
	NULL,
	sf_write,
	sf_apply,
	sf_macroexpand,
};


SExp gen_specialform(SpecialFormType cfunc, const char* name, int minargnum, int maxargnum) {
	SpecialForm* p = smalloc(sizeof(*p));
	p->typeinfo = &sf_typeinfo;
	p->cfunc = cfunc;
	p->name = name;
	p->minargnum = minargnum;
	p->maxargnum = maxargnum;
	return ptr2s(p);
}


//=============================================================================
// Subr

static void subr_write(SExp s, SExp strm, int escape) {
	Subr* p = &s.ptr->subr;
	write_cstr("#<subr: ", strm);
	write_cstr(p->name, strm);
	write_cstr(">", strm);
}

static SExp subr_apply(SExp fn, SExp args, int not_evaled) {
	Subr* subr = &fn.ptr->subr;
	SExp res;
	SExp* frame;
	int n = evlis(&frame, args, not_evaled);
	if (!check_argnum(n, subr->minargnum, subr->maxargnum)) {
		res = argnum_error(intern(subr->name), n, subr->minargnum, subr->maxargnum);
	} else {
		res = (subr->cfunc)(n, frame);
	}
	pop_stack(n);
	return res;
}

static STypeInfo subr_typeinfo = {
	tSubr,	0,
	"fn",
	NULL,
	NULL,
	NULL,
	subr_write,
	subr_apply,
	NULL,
};


SExp gen_subr(SubrType cfunc, const char* name, int minargnum, int maxargnum) {
	Subr* p = smalloc(sizeof(*p));
	p->typeinfo = &subr_typeinfo;
	p->cfunc = cfunc;
	p->name = name;
	p->minargnum = minargnum;
	p->maxargnum = maxargnum;
	return ptr2s(p);
}


//=============================================================================
// Lambda

static const int lambda_sexp_ofstbl[] = {
	offsetof(Lambda, name),
	offsetof(Lambda, arglist),
	offsetof(Lambda, body),
	offsetof(Lambda, lexical_env),
	-1,
};

static void lambda_write(SExp s, SExp strm, int escape) {
	Lambda* p = &s.ptr->lambda;
	format(strm, "#<lambda: ~a>", NULL, p->name);
}

static SExp eval_lambda_bodies(Lambda* lambda) {
	SExp p, res = nil;
	for (p = lambda->body; !nilp(p); p = cdr(p)) {
		SExp a = car(p);
		res = run(a);
	}
	return res;
}

static SExp lambda_apply(SExp fn, SExp args, int not_evaled) {
	Lambda* lambda = &fn.ptr->lambda;
	SExp res;
	SExp* frame;
	int n = evlis(&frame, args, not_evaled);
	if (!check_argnum(n, lambda->minargnum, lambda->maxargnum)) {
		res = argnum_error(intern("lambda"), n, lambda->minargnum, lambda->maxargnum);
	} else {
		push_stack(get_current_env()); {
			set_env(lambda->lexical_env);	// switch to lexical env
			extend_env(lambda->arglist, frame, n);
			res = eval_lambda_bodies(lambda);
		} set_env(pop_stack(1));
	}
	pop_stack(n);
	return res;
}


static STypeInfo lambda_typeinfo = {
	tLambda,	0,
	"fn",
	lambda_sexp_ofstbl,
	NULL,
	NULL,
	lambda_write,
	lambda_apply,
	NULL,
};

/// Check if elements of list are all symbol?
static int arglist_elems_are_symbol(SExp arglist) {
	int r = TRUE;
	int idx;
	SExp p, s;
	for (p=arglist, idx=0; consp(p); p=cdr(p), ++idx) {
		s = car(p);
		if (!symbolp(s)) {
			r = FALSE;
			break;
		}
	}
	if (r && !nilp(p)) {
		s = p;
		if (!symbolp(s)) {
			r = FALSE;
		}
	}
	if (!r) {
		error(ERR_ARGLIST_MUST_BE_SYMBOL, s);
	}
	return r;
}

/// Check if elements of list are not same each other?
static int different_each_other(SExp arglist) {
	SExp p, s;
	for (p=arglist; consp(p); p=cdr(p)) {
		s = car(p);
		if (!nilp(member(s, cdr(p)))) {
			goto L_error;
		}
	}
	if (!nilp(p)) {
		s = p;
		if (!nilp(member(s, arglist))) {
L_error:;
			error(ERR_DUPLICATE_ARGNAME, s);
			return FALSE;
		}
	}
	return TRUE;

}

SExp gen_lambda(SExp arglist, SExp body, SExp lexical_env) {
	Lambda* p;
	if (!arglist_elems_are_symbol(arglist) || !different_each_other(arglist)) {
		return nil;
	}
	p = smalloc(sizeof(*p));
	p->typeinfo = &lambda_typeinfo;
	p->name = nil;
	p->arglist = arglist;
	p->body = body;
	if (consp(p->arglist)) {
		p->minargnum = list_length(p->arglist);
		p->maxargnum = nilp(cdr(last1(p->arglist))) ? p->minargnum : -1;
	} else {
		p->minargnum = 0;
		p->maxargnum = -1;
	}
	p->lexical_env = lexical_env;
	return ptr2s(p);
}



//=============================================================================
// Macro

// expand only
static SExp macex(SExp fn, SExp args) {
	Macro* macro = &fn.ptr->macro;
	SExp* frame;
	int n = evlis(&frame, args, FALSE);
	SExp res;
	if (!check_argnum(n, macro->minargnum, macro->maxargnum)) {
		res = argnum_error(intern("macro"), n, macro->minargnum, macro->maxargnum);
	} else {
		push_stack(get_current_env()); {
			SExp p;
			set_env(macro->lexical_env);
			extend_env(macro->arglist, frame, n);
			for (p = macro->body; !nilp(p); p = cdr(p)) {
				SExp a = car(p);
				res = run(a);
			}
		} set_env(pop_stack(1));
	}
	pop_stack(n);
	return res;
}

static const int macro_sexp_ofstbl[] = {
	offsetof(Macro, name),
	offsetof(Macro, arglist),
	offsetof(Macro, body),
	offsetof(Macro, lexical_env),
	-1,
};

static void macro_write(SExp s, SExp strm, int escape) {
	Macro* p = &s.ptr->macro;
	format(strm, "#<macro: ~a>", NULL, p->name);
}

static SExp macro_apply(SExp fn, SExp args, int not_evaled) {
	// expand + eval
	SExp expanded = macex(fn, args);
	SExp res;
	push_stack(expanded);
	res = run(expanded);
	pop_stack(1);
	return res;
}

static SExp macro_macroexpand(SExp self, SExp s) {
	SExp args = cdr(s);
	return macex(self, args);
}

static STypeInfo macro_typeinfo = {
	tMacro,	0,
	"mac",
	macro_sexp_ofstbl,
	NULL,
	NULL,
	macro_write,
	macro_apply,
	macro_macroexpand,
};


SExp gen_macro(SExp arglist, SExp body, SExp lexical_env) {
	Macro* p;
	if (!arglist_elems_are_symbol(arglist) || !different_each_other(arglist)) {
		return nil;
	}
	p = smalloc(sizeof(*p));
	p->typeinfo = &macro_typeinfo;
	p->name = nil;
	p->arglist = arglist;
	p->body = body;
	if (consp(p->arglist)) {
		p->minargnum = list_length(p->arglist);
		p->maxargnum = nilp(cdr(last1(p->arglist))) ? p->minargnum : -1;
	} else {
		p->minargnum = 0;
		p->maxargnum = -1;
	}
	p->lexical_env = lexical_env;
	return ptr2s(p);
}


//=============================================================================
// ReadCell

#define	FLG_READCELL		(1)

static const int rcell_sexp_ofstbl[] = {
	offsetof(Cell, car),
	offsetof(Cell, cdr),
	offsetof(ReadCell, filename),
	-1,
};

static STypeInfo rcell_typeinfo = {
	tCell,	FLG_READCELL,
	"cons",
	cell_sexp_ofstbl,
	NULL,
	NULL,
	cell_write,
	NULL,
	cell_macroexpand,
};

SExp cons_ext(SExp a, SExp d, SExp filename, int lineno, int colno) {
	ReadCell* p = smalloc(sizeof(*p));
	p->base.typeinfo = &rcell_typeinfo;
	p->base.car = a;
	p->base.cdr = d;
	p->filename = filename;
	p->lineno = lineno;
	p->colno = colno;
	return ptr2s(p);
}

int cons_extp(SExp s) {
	return get_type_info(s) == &rcell_typeinfo;
}


//=============================================================================


const STypeInfo* get_type_info(SExp s) {
	switch ((int)s.ptr & 3) {
	case 0:			// sptr
		return s.ptr->hdr.typeinfo;
		break;
	case 1: case 3:	// fixnum
		return &fixnum_typeinfo;
	default:		//case 2:
		switch (GET_SUBTYPE(s.i)) {
		default:			return &unknown_typeinfo;
		case SUBTYPE_CHAR:	return &char_typeinfo;
		}
	}
}

void set_name(SExp s, SExp sym) {
	switch (type_of(s)) {
	case tLambda:
		{
			Lambda* p = &s.ptr->lambda;
			if (nilp(p->name))	p->name = sym;
		}
		break;
	case tMacro:
		{
			Macro* p = &s.ptr->macro;
			if (nilp(p->name))	p->name = sym;
		}
		break;
	}
}
